home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
turbo_tk.arc
/
PULLTTT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-01
|
22KB
|
593 lines
{$S-,R-,V-,D-,T-}
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
{ TechnoJocks Turbo Toolkit v4.00 Released: Feb 1, 1988 }
{ }
{ Module: PullTTT -- Pull down menu system a la DBase III+ }
{ }
{ Copyright R. D. Ainsbury (c) 1986 }
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
Unit PULLTTT;
Interface
Uses CRT, FastTTT, DOS, WinTTT, KeyTTT;
type
MenuDesc = array [1..60] of string[30];
MenuDisplay = record
TopX:byte;
TopY:byte;
Style:byte;
ScreenNo:byte;
FCol: byte; {normal option foreground color}
BCol: byte; {normal option background color}
CCol: byte; {color of first Character}
MBCol: byte; {highlight bgnd col for main pick when sub-menu displayed}
HFCol: byte; {highlighted option foreground}
HBCol: byte; {highlighted option background}
BorCol: byte; {border foreground color}
Gap : byte; {Gap between Picks}
AllowEsc : boolean; {is Escape key operative}
RemoveMenu: boolean;{clear screen on exit}
end;
Const
Max_MainPicks = 8;
Max_Subpicks = 10;
MainInd = '\'; {symbol that indicates main menu description}
Var
PM : MenuDisplay;
PM_UserHook : pointer;
Procedure Pull_Menu( Definition:MenuDesc; var PickM, PickS:byte);
Implementation
Procedure CallFromPM(var Ch: char; Main, Sub :byte);
Inline($FF/$1E/PM_UserHook);
Procedure Default_Settings;
begin
PM_UserHook := nil;
PM.TopY := 1;
PM.TopX := 1;
PM.Style := 1;
PM.ScreenNo := 1;
PM.Gap := 2;
PM.AllowEsc := true;
PM.RemoveMenu := true;
If BaseOfScreen = $b000 then {monochrome}
begin
PM.FCol := lightgray;
PM.BCol := black;
PM.CCol := white;
PM.MBCol := lightgray;
PM.HFCol := black;
PM.HBCol := lightgray;
PM.BorCol := lightgray;
end
else {color}
begin
PM.FCol := yellow;
PM.BCol := blue;
PM.CCol := lightcyan;
PM.MBCol := red;
PM.HFCol := yellow;
PM.HBCol := red;
PM.BorCol := cyan;
end;
end; {Proc Default_Settings}
Procedure Pull_Menu( Definition:MenuDesc; var PickM, PickS:byte);
const
LeftChar = #016; {arrow to highlight current pick}
RightChar = #017; {arrow to highlight current pick}
CursUp = #200 ; CursDown = #208 ; CursLeft = #203 ; CursRight = #205;
HomeKey = #199 ; Endkey = #207 ; Esc = #027 ; Enter = #13;
F1 = #187 ;
type
Sub_details = record
Text: Array[0..Max_SubPicks] of string[30];
Total: byte;
Width: byte;
LastPick: byte;
end;
var
Submenu : array [1..Max_MainPicks] of Sub_Details;
Tot_main : byte; {total number of main picks}
Main_Wid : byte; {width of main menu box}
Finished, {has user selected menu option}
Down : boolean; {indicates if sub-menu displayed}
ChM,ChT : char; {keypressed character}
X1, Y1, X2, Y2 : byte; {lower menu borders}
Cap,Count : byte; {used to check if letter pressed = first char}
I : integer;
TLchar, {border submenu upper left char}
TRchar, {border submenu upper right char}
BLchar, {border submenu bottom left char}
BRchar, {border submenu bottom right char}
Joinchar, {border joining character}
Joindownchar, {border joining character}
JoinleftChar, {border joining character}
VertChar, {border vert character}
Horizchar:char; {border horiz char}
Procedure PullError(No : byte);
var M : string;
begin
Case No of
1 : M := 'Menu definiton must start with a Main ("\") description';
2 : M := 'Main menu definition must be at least 1 character';
3 : M := 'Too many main menu picks.';
4 : M := 'Too many sub-menu picks.';
5 : M := 'No end of menu indicator found';
6 : M := 'Must be at least two sub-menus';
7 : M := 'Main menu will not fit in 80 characters';
end; {case}
Writeln;
Writeln(M);
Halt;
end; {Abort}
Procedure Set_Style;
{Sets variables for the box characters based on defined style}
begin
Case PM.Style of
1 : begin
TLchar := #218;
TRchar := #191;
BLchar := #192;
BRchar := #217;
Joinchar := #194;
Joindownchar := #193;
JoinleftChar := #180;
VertChar := #179;
Horizchar := #196;
end;
2 : begin
TLchar := #201;
TRchar := #187;
BLchar := #200;
BRchar := #188;
Joinchar := #203;
Joindownchar := #202;
JoinleftChar := #185;
VertChar := #186;
Horizchar := #205;
end;
else
begin
TLchar := ' ';
TRchar := ' ';
BLchar := ' ';
BRchar := ' ';
Joinchar := ' ';
Joindownchar := ' ';
JoinleftChar := ' ';
VertChar := ' ';
Horizchar := ' ';
end;
end; {Case}
end; {Proc Set_Style}
Procedure Load_Menu_Parameters;
{ converts the MenuDesc array into the Sub_menu array, and
determines Tot_main
}
var
I, Maj, Min, Widest : integer;
Instr : string[30];
begin
FillChar(Submenu,sizeof(Submenu),#0);
Tot_main := 0;
If Definition[1][1] <> '\' then PullError(1);
Maj := 0;
Widest := 0;
For I := 1 to 60 do
begin
Instr := Definition[I];
If Instr[1] = MainInd then
begin
If Maj <> 0 then {update values for last sub menu}
begin
SubMenu[Maj].Total := Min;
SubMenu[Maj].Width := widest;
end;
If length(Instr) < 2 then PullError(2);
If Instr = Mainind + mainind then {must have loaded all data}
begin {note number of main menu }
Tot_main := Maj; {picks and exit}
exit;
end;
Maj := succ(Maj);
If Maj > Max_mainpicks then PullError(3);
delete(Instr,1,1);
SubMenu[Maj].text[0] := Instr;
Min := 0; {reset values for next sub heading}
Widest := 0;
end
else {not a main menu heading}
begin
Min := succ(Min);
If Min > Max_SubPicks then PullError(4);
SubMenu[Maj].text[Min] := Instr;
If length(Instr) > widest then
widest := length(Instr);
end; {if main heading}
end; {for 1 to 60}
If Tot_main = 0 then PullError(5);
If Tot_main < 2 then PullError(6);
end; {sub-proc Load_Menu_Parameters}
Function First_Capital(InStr:string; Var StrPos:byte):char;
{returns the first capital letter in a string and Character position}
begin
StrPos := 1;
While (StrPos <= length(InStr)) and ((InStr[StrPos] in [#65..#90]) = false) do
StrPos := Succ(StrPos);
If StrPos > length(InStr) then
begin
StrPos := 0;
First_Capital := ' ';
end
else
First_Capital := InStr[StrPos];
end; {First_Capital}
Procedure Display_Main_Picks(No : byte; Col : byte);
{ displays main heading for menu pick 'No', if Col = 1 then
PM.HFCol and PM.MBCol cols are used without arrows, else PM.FCol and PM.BCol
colors are used}
var
ChT : Char;
X, I, B : byte;
begin
X := 1;
If No = 1 then
X := X + PM.TopX + PM.Gap
else
begin
For I := 1 to No - 1 do
X := X + length(Submenu[I].Text[0]) + PM.Gap;
X := X + PM.TopX + PM.Gap ;
end;
If Col > 0 then
Fastwrite(X,PM.TopY+ord(PM.Style>0),attr(PM.HFCol,PM.MBCol),
Submenu[No].Text[0])
else
begin
Fastwrite(X,PM.TopY+ord(PM.Style>0),attr(PM.FCol,PM.BCol),
+Submenu[No].Text[0]);
ChT := First_Capital(Submenu[No].Text[0],B);
If B <> 0 then
FastWrite(pred(X)+B,PM.TopY+ord(PM.Style>0),
attr(PM.CCol,PM.BCol),ChT);
end;
GotoXY(X,PM.TopY+Ord(PM.Style>0));
end; {Display Main Header}
Procedure Display_Main_Menu;
{draws boxes, main menu picks and draws border}
var I : byte;
begin
{draw the box}
Main_Wid := succ(PM.Gap) ; {determine the width of the main menu}
For I := 1 to Tot_Main do
Main_Wid := Main_Wid + PM.Gap + length(Submenu[I].text[0]);
If Main_Wid + PM.TopX - 1 > 80 then PullError(7);
If PM.Style = 0 then
ClearText(PM.TopX,PM.TopY,PM.TopX + Main_Wid,PM.TopY,PM.BorCol,PM.BCol)
else
Fbox(PM.TopX,PM.TopY,PM.TopX + Main_Wid,PM.TopY + 2,PM.BorCol,PM.BCol,PM.Style);
For I := 1 to ToT_Main do
Display_Main_Picks(I,0);
Display_Main_Picks(PickM,1);
end; {Display_Main_Menu}
Procedure Remove_Sub_Menu;
var a : integer;
begin
Fastwrite(X1,PM.TopY+2,attr(PM.BorCol,PM.BCol),horizchar);
Fastwrite(X2,PM.TopY+2,attr(PM.BorCol,PM.BCol),horizchar);
PartRestoreScreen(PM.ScreenNo, PM.TopX, succ(PM.TopY)+2*ord(PM.Style>0), 80, 25,
PM.TopX, succ(PM.TopY)+2*ord(PM.Style>0));
If (PM.Style > 0 ) and (X2 >= PM.TopX + Main_wid) then
begin
A := PM.TopX +Main_Wid + 1;
PartRestoreScreen(PM.ScreenNo, A, PM.TopY + 2, 80, PM.TopY + 2, A, PM.TopY + 2);
Fastwrite(A - 1, PM.TopY+2, attr(PM.BorCol,PM.BCol),BRchar);
end;
SubMenu[PickM].LastPick := PickS;
end;
Procedure Display_Sub_Picks(No : byte; Col : byte);
{ displays sub menu pick 'No', if Col = 1 then
PM.HFCol and PM.HBCol cols are used and arrows, else PM.FCol and PM.BCol
colors are used}
var
ChT : Char;
B : Byte;
begin
If Col = 1 then
Fastwrite(X1 + 1, succ(PM.TopY)+ord(PM.Style>0) + No ,
attr(PM.HFCol,PM.HBCol),
LeftChar + Submenu[PickM].Text[No] + Rightchar)
else
begin
Fastwrite(X1 + 1, succ(PM.TopY)+Ord(PM.Style>0) + No ,
attr(PM.FCol,PM.BCol),
' '+Submenu[PickM].Text[No]+' ');
ChT := First_Capital(SubMenu[PickM].Text[No],B);
If B <> 0 then
FastWrite(X1+1+B,succ(PM.TopY)+Ord(PM.Style>0) + No ,
attr(PM.CCol,PM.BCol),ChT);
end;
GotoXY(X1+1,succ(PM.TopY)+ord(Pm.Style>0)+ No);
end;
Procedure Display_Sub_Menu(No :byte);
var
BotLine : string;
I : byte;
begin
Down := true;
If (Submenu[pickM].Total = 0) then exit;
X1 := pred(PM.TopX); {determine box coords of sub menu}
If No <> 1 then
begin
For I := 1 to pred(No) do
X1 := X1 + PM.Gap + length(Submenu[I].text[0]);
X1 := pred(X1) + PM.Gap ;
end
else
X1 := X1 + 2;
X2 := X1 + Submenu[No].width + 3;
If X2 > 80 then
begin
X1 := 80 - (X2 - X1) ;
X2 := 80;
end;
Y1 := succ(PM.TopY) + ord(PM.Style>0);
Y2 := Y1 + 1 + Submenu[No].total;
Fbox(X1,Y1,X2,Y2,PM.BorCol,PM.BCol,PM.Style);
Fastwrite(X1,succ(PM.TopY)+ord(PM.Style>0),attr(PM.BorCol,PM.BCol),Joinchar);
If X2 < PM.TopX + Main_wid then
Fastwrite(X2,succ(PM.TopY)+ord(PM.Style>0),attr(PM.BorCol,PM.BCol),Joinchar)
else
If X2 = PM.TopX + Main_wid then
Fastwrite(X2,succ(PM.TopY)+ord(PM.Style>0),attr(PM.BorCol,PM.BCol),Joinleftchar)
else
begin
Fastwrite(X2,PM.TopY+2,attr(PM.BorCol,PM.BCol),TRchar);
Fastwrite(PM.TopX+Main_wid,succ(PM.TopY)+ord(PM.Style>0),attr(PM.BorCol,PM.BCol),Joindownchar);
end;
For I := 1 to Submenu[PickM].total do
Display_Sub_Picks(I,2);
PickS := SubMenu[PickM].LastPick;
If not (PickS in [1..Submenu[PickM].Total]) then
PickS := 1;
Display_Sub_Picks(PickS,1);
end; {proc Display_Sub_Menu}
begin {Main Procedure Display_menu}
Set_Style;
Load_Menu_Parameters;
SaveScreen(PM.ScreenNo);
Finished := false;
Display_Main_Menu;
For I := 1 to Tot_main do
Submenu[I].lastPick := 1;
SubMenu[PickM].LastPick := PickS;
If PickS <> 0 then
begin
Display_Sub_Menu(PickM);
Down := true;
end
else
Down := false;
Repeat
ChM := GetKey;
If PM_UserHook <> nil then
If Down then
CallFromPM(ChM,PickM,PickS)
else
CallFromPM(ChM,PickM,0);
Case upcase(ChM) of
'A'..'Z' : If down then {check if letter is first letter of menu option}
begin
Count := 0;
Repeat
Count := succ(count);
ChT := First_Capital(Submenu[PickM].Text[count],Cap);
If ChT = upcase(ChM) then
begin
Finished := true;
Display_Sub_Picks(PickS,0);
PickS := Count;
Display_Sub_Picks(PickS,1);
end;
Until (Finished) or (count = submenu[PickM].Total);
end
else {down false}
begin
Count := 0;
Repeat
Count := succ(count);
ChT := First_Capital(Submenu[Count].Text[0],Cap);
If ChT = upcase(ChM) then
begin
Display_Main_Picks(PickM,0);
PickM := Count;
Down := true;
Display_Main_Picks(PickM,2);
If not (PickS in [1..Submenu[PickM].Total]) then
PickS := 1;
Display_Sub_Menu(PickM);
end;
Until (Down) or (count = Tot_Main);
end;
#133, {Mouse Enter}
Enter : If Down or (Submenu[PickM].Total = 0) then
begin
Finished := true;
If Submenu[PickM].Total = 0 then PickS := 0;
end
else
begin
Down := true;
Display_Main_Picks(PickM,2);
Display_Sub_Menu(PickM);
end;
#132, {Mouse Esc}
Esc : If Down then
begin
Down := false;
Remove_sub_menu;
Display_Main_menu;
end
else
If PM.AllowEsc then
begin
Finished := true;
PickM := 0;
end;
#131 : If PickM < ToT_main then
begin
Display_main_picks(PickM,0); {clear highlight}
If Down then
Remove_Sub_Menu;
PickM := succ(PickM);
Display_Main_Picks(PickM,1);
If down then
Display_Sub_Menu(PickM);
end;
CursRight : begin
Display_main_picks(PickM,0); {clear highlight}
If Down then
Remove_Sub_Menu;
If PickM < ToT_main then
PickM := PickM + 1
else
PickM := 1;
Display_Main_Picks(PickM,1);
If down then
Display_Sub_Menu(PickM);
end;
#130 : If PickM > 1 then {MouseLeft}
begin
Display_main_picks(PickM,0); {clear highlight}
If Down then
Remove_Sub_Menu;
PickM := pred(PickM);
Display_Main_Picks(PickM,1);
If down then
Display_Sub_Menu(PickM);
end;
CursLeft : begin
Display_main_picks(PickM,0); {clear highlight}
If Down then
Remove_Sub_Menu;
If PickM > 1 then
PickM := pred(PickM)
else
PickM := Tot_Main;
Display_Main_Picks(PickM,1);
If down then
Display_Sub_Menu(PickM);
end;
#129 : If (Submenu[PickM].Total <> 0) then
begin
If Not Down then {Mouse Down}
begin
Down := true;
Display_Main_Picks(PickM,2);
Display_Sub_Menu(PickM);
end
else
If PickS < Submenu[PickM].Total then
begin
Display_Sub_Picks(PickS,0);
PickS := succ(PickS);
Display_Sub_Picks(PickS,1);
end;
end;
CursDown : If (Submenu[PickM].Total <> 0) then
begin
If Not Down then
begin
Down := true;
Display_Main_Picks(PickM,2);
Display_Sub_Menu(PickM);
end
else
begin
Display_Sub_Picks(PickS,0);
If PickS < Submenu[PickM].Total then
PickS := succ(PickS)
else
PickS := 1;
Display_Sub_Picks(PickS,1);
end;
end;
#128 : If down and (Picks > 1) then
begin
Display_Sub_Picks(PickS,0);
PickS := pred(PickS);
Display_Sub_Picks(PickS,1);
end;
CursUp : If down then
begin
Display_Sub_Picks(PickS,0);
If PickS <> 1 then
PickS := pred(PickS)
else
PickS := Submenu[PickM].Total;
Display_Sub_Picks(PickS,1);
end;
EndKey : If Down then
begin
Display_Sub_Picks(PickS,0);
PickS := Submenu[PickM].Total;
Display_Sub_Picks(PickS,1);
end
else
begin
Display_main_picks(PickM,0); {clear highlight}
PickM := ToT_Main;
Display_main_picks(PickM,1);
end;
HomeKey : If Down then
begin
Display_Sub_Picks(PickS,0);
PickS := 1;
Display_Sub_Picks(PickS,1);
end
else
begin
Display_main_picks(PickM,0); {clear highlight}
PickM := 1;
Display_main_picks(PickM,1);
end;
end; {endcase}
Until Finished;
If PM.RemoveMenu Then
RestoreScreen(PM.ScreenNo);
DisposeScreen(PM.ScreenNo);
end; {end of main procedure Display_Menu}
begin
Horiz_Sensitivity := 4; {cursors left and right before mouse returns}
Default_Settings;
end.